home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.5.6 / ice-9 / getopt-long.scm.z / getopt-long.scm
Text File  |  2002-07-08  |  21KB  |  450 lines
  1. ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
  2. ;;;
  3. ;;; This program is free software; you can redistribute it and/or modify
  4. ;;; it under the terms of the GNU General Public License as published by
  5. ;;; the Free Software Foundation; either version 2 of the License, or
  6. ;;; (at your option) any later version.
  7. ;;;
  8. ;;; This program is distributed in the hope that it will be useful,
  9. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;; GNU General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU General Public License
  14. ;;; along with this program; if not, write to the Free Software
  15. ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16. ;;;
  17. ;;; As a special exception, the Free Software Foundation gives permission
  18. ;;; for additional uses of the text contained in its release of GUILE.
  19. ;;;
  20. ;;; The exception is that, if you link the GUILE library with other files
  21. ;;; to produce an executable, this does not by itself cause the
  22. ;;; resulting executable to be covered by the GNU General Public License.
  23. ;;; Your use of that executable is in no way restricted on account of
  24. ;;; linking the GUILE library code into it.
  25. ;;;
  26. ;;; This exception does not however invalidate any other reasons why
  27. ;;; the executable file might be covered by the GNU General Public License.
  28. ;;;
  29. ;;; This exception applies only to the code released by the
  30. ;;; Free Software Foundation under the name GUILE.  If you copy
  31. ;;; code from other Free Software Foundation releases into a copy of
  32. ;;; GUILE, as the General Public License permits, the exception does
  33. ;;; not apply to the code that you add in this way.  To avoid misleading
  34. ;;; anyone as to the status of such modified files, you must delete
  35. ;;; this exception notice from them.
  36. ;;;
  37. ;;; If you write modifications of your own for GUILE, it is your choice
  38. ;;; whether to permit this exception to apply to your modifications.
  39. ;;; If you do not wish that, delete this exception notice.
  40.  
  41. ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
  42.  
  43. ;;; Commentary:
  44.  
  45. ;;; This module implements some complex command line option parsing, in
  46. ;;; the spirit of the GNU C library function `getopt_long'.  Both long
  47. ;;; and short options are supported.
  48. ;;;
  49. ;;; The theory is that people should be able to constrain the set of
  50. ;;; options they want to process using a grammar, rather than some arbitrary
  51. ;;; structure.  The grammar makes the option descriptions easy to read.
  52. ;;;
  53. ;;; `getopt-long' is a procedure for parsing command-line arguments in a
  54. ;;; manner consistent with other GNU programs.  `option-ref' is a procedure
  55. ;;; that facilitates processing of the `getopt-long' return value.
  56.  
  57. ;;; (getopt-long ARGS GRAMMAR)
  58. ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  59. ;;;
  60. ;;; ARGS should be a list of strings.  Its first element should be the
  61. ;;; name of the program; subsequent elements should be the arguments
  62. ;;; that were passed to the program on the command line.  The
  63. ;;; `program-arguments' procedure returns a list of this form.
  64. ;;;
  65. ;;; GRAMMAR is a list of the form:
  66. ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  67. ;;;
  68. ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  69. ;;; command-line option named `--OPTION'.
  70. ;;; Each option can have the following (PROPERTY VALUE) pairs:
  71. ;;;
  72. ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  73. ;;;        equivalent to `--OPTION'.  This is how to specify traditional
  74. ;;;        Unix-style flags.
  75. ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  76. ;;;        getopt-long will raise an error if it is not found in ARGS.
  77. ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  78. ;;;        it is #f, it does not; and if it is the symbol
  79. ;;;        `optional', the option may appear in ARGS with or
  80. ;;;        without a value.
  81. ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  82. ;;;        specified `(value #t)' for this option), then getopt
  83. ;;;        will apply FUNC to the value, and throw an exception
  84. ;;;        if it returns #f.  FUNC should be a procedure which
  85. ;;;        accepts a string and returns a boolean value; you may
  86. ;;;        need to use quasiquotes to get it into GRAMMAR.
  87. ;;;
  88. ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  89. ;;; property may occur only once.  By default, options do not have
  90. ;;; single-character equivalents, are not required, and do not take
  91. ;;; values.
  92. ;;;
  93. ;;; In ARGS, single-character options may be combined, in the usual
  94. ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  95. ;;; accepts values, then it must be the last option in the
  96. ;;; combination; the value is the next argument.  So, for example, using
  97. ;;; the following grammar:
  98. ;;;      ((apples    (single-char #\a))
  99. ;;;       (blimps    (single-char #\b) (value #t))
  100. ;;;       (catalexis (single-char #\c) (value #t)))
  101. ;;; the following argument lists would be acceptable:
  102. ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  103. ;;;                                         for "blimps" and "catalexis")
  104. ;;;    ("-ab" "bang" "-c" "couth")         (same)
  105. ;;;    ("-ac" "couth" "-b" "bang")         (same)
  106. ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  107. ;;;                                         last option in its combination)
  108. ;;;
  109. ;;; If an option's value is optional, then `getopt-long' decides
  110. ;;; whether it has a value by looking at what follows it in ARGS.  If
  111. ;;; the next element is does not appear to be an option itself, then
  112. ;;; that element is the option's value.
  113. ;;;
  114. ;;; The value of a long option can appear as the next element in ARGS,
  115. ;;; or it can follow the option name, separated by an `=' character.
  116. ;;; Thus, using the same grammar as above, the following argument lists
  117. ;;; are equivalent:
  118. ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  119. ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  120. ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
  121. ;;;
  122. ;;; If the option "--" appears in ARGS, argument parsing stops there;
  123. ;;; subsequent arguments are returned as ordinary arguments, even if
  124. ;;; they resemble options.  So, in the argument list:
  125. ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
  126. ;;; `getopt-long' will recognize the `apples' option as having the
  127. ;;; value "Granny Smith", but it will not recognize the `blimp'
  128. ;;; option; it will return the strings "--blimp" and "Goodyear" as
  129. ;;; ordinary argument strings.
  130. ;;;
  131. ;;; The `getopt-long' function returns the parsed argument list as an
  132. ;;; assocation list, mapping option names --- the symbols from GRAMMAR
  133. ;;; --- onto their values, or #t if the option does not accept a value.
  134. ;;; Unused options do not appear in the alist.
  135. ;;;
  136. ;;; All arguments that are not the value of any option are returned
  137. ;;; as a list, associated with the empty list.
  138. ;;;
  139. ;;; `getopt-long' throws an exception if:
  140. ;;; - it finds an unrecognized property in GRAMMAR
  141. ;;; - the value of the `single-char' property is not a character
  142. ;;; - it finds an unrecognized option in ARGS
  143. ;;; - a required option is omitted
  144. ;;; - an option that requires an argument doesn't get one
  145. ;;; - an option that doesn't accept an argument does get one (this can
  146. ;;;   only happen using the long option `--opt=value' syntax)
  147. ;;; - an option predicate fails
  148. ;;;
  149. ;;; So, for example:
  150. ;;;
  151. ;;; (define grammar
  152. ;;;   `((lockfile-dir (required? #t)
  153. ;;;                   (value #t)
  154. ;;;                   (single-char #\k)
  155. ;;;                   (predicate ,file-is-directory?))
  156. ;;;     (verbose (required? #f)
  157. ;;;              (single-char #\v)
  158. ;;;              (value #f))
  159. ;;;     (x-includes (single-char #\x))
  160. ;;;     (rnet-server (single-char #\y)
  161. ;;;                  (predicate ,string?))))
  162. ;;;
  163. ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
  164. ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
  165. ;;;                grammar)
  166. ;;; => ((() "foo1" "-fred" "foo2" "foo3")
  167. ;;;     (rnet-server . "lamprod")
  168. ;;;     (x-includes . "/usr/include")
  169. ;;;     (lockfile-dir . "/tmp")
  170. ;;;     (verbose . #t))
  171.  
  172. ;;; (option-ref OPTIONS KEY DEFAULT)
  173. ;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
  174. ;;; found.  The value is either a string or `#t'.
  175. ;;;
  176. ;;; For example, using the `getopt-long' return value from above:
  177. ;;;
  178. ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
  179. ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
  180.  
  181. ;;; Code:
  182.  
  183. (define-module (ice-9 getopt-long)
  184.   :use-module ((ice-9 common-list) :select (some remove-if-not))
  185.   :export (getopt-long option-ref))
  186.  
  187. (define option-spec-fields '(name
  188.                              value
  189.                              required?
  190.                              single-char
  191.                              predicate
  192.                              value-policy))
  193.  
  194. (define option-spec (make-record-type 'option-spec option-spec-fields))
  195. (define make-option-spec (record-constructor option-spec option-spec-fields))
  196.  
  197. (define (define-one-option-spec-field-accessor field)
  198.   `(define ,(symbol-append 'option-spec-> field)        ;;; name slib-compat
  199.      (record-accessor option-spec ',field)))
  200.  
  201. (define (define-one-option-spec-field-modifier field)
  202.   `(define ,(symbol-append 'set-option-spec- field '!)  ;;; name slib-compat
  203.      (record-modifier option-spec ',field)))
  204.  
  205. (defmacro define-all-option-spec-accessors/modifiers ()
  206.   `(begin
  207.      ,@(map define-one-option-spec-field-accessor option-spec-fields)
  208.      ,@(map define-one-option-spec-field-modifier option-spec-fields)))
  209.  
  210. (define-all-option-spec-accessors/modifiers)
  211.  
  212. (define make-option-spec
  213.   (let ((ctor (record-constructor option-spec '(name))))
  214.     (lambda (name)
  215.       (ctor name))))
  216.  
  217. (define (parse-option-spec desc)
  218.   (let ((spec (make-option-spec (symbol->string (car desc)))))
  219.     (for-each (lambda (desc-elem)
  220.                 (let ((given (lambda () (cadr desc-elem))))
  221.                   (case (car desc-elem)
  222.                     ((required?)
  223.                      (set-option-spec-required?! spec (given)))
  224.                     ((value)
  225.                      (set-option-spec-value-policy! spec (given)))
  226.                     ((single-char)
  227.                      (or (char? (given))
  228.                          (error "`single-char' value must be a char!"))
  229.                      (set-option-spec-single-char! spec (given)))
  230.                     ((predicate)
  231.                      (set-option-spec-predicate!
  232.                       spec ((lambda (pred)
  233.                               (lambda (name val)
  234.                                 (or (not val)
  235.                                     (pred val)
  236.                                     (error "option predicate failed:" name))))
  237.                             (given))))
  238.                     (else
  239.                      (error "invalid getopt-long option property:"
  240.                             (car desc-elem))))))
  241.               (cdr desc))
  242.     spec))
  243.  
  244. (define (split-arg-list argument-list)
  245.   ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
  246.   ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
  247.   (let loop ((yes '()) (no argument-list))
  248.     (cond ((null? no)               (cons (reverse yes) no))
  249.       ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
  250.       (else (loop (cons (car no) yes) (cdr no))))))
  251.  
  252. (define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
  253. (define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
  254. (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
  255.  
  256. (define (match-substring match which)
  257.   ;; condensed from (ice-9 regex) `match:{substring,start,end}'
  258.   (let ((sel (vector-ref match (1+ which))))
  259.     (substring (vector-ref match 0) (car sel) (cdr sel))))
  260.  
  261. (define (expand-clumped-singles opt-ls)
  262.   ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
  263.   (let loop ((opt-ls opt-ls) (ret-ls '()))
  264.     (cond ((null? opt-ls)
  265.            (reverse ret-ls))                                    ;;; retval
  266.           ((regexp-exec short-opt-rx (car opt-ls))
  267.            => (lambda (match)
  268.                 (let ((singles (reverse
  269.                                 (map (lambda (c)
  270.                                        (string-append "-" (make-string 1 c)))
  271.                                      (string->list
  272.                                       (match-substring match 1)))))
  273.                       (extra (match-substring match 2)))
  274.                   (loop (cdr opt-ls)
  275.                         (append (if (string=? "" extra)
  276.                                     singles
  277.                                     (cons extra singles))
  278.                                 ret-ls)))))
  279.           (else (loop (cdr opt-ls)
  280.                       (cons (car opt-ls) ret-ls))))))
  281.  
  282. (define (looks-like-an-option string)
  283.   (some (lambda (rx)
  284.           (regexp-exec rx string))
  285.         `(,short-opt-rx
  286.           ,long-opt-with-value-rx
  287.           ,long-opt-no-value-rx)))
  288.  
  289. (define (process-options specs argument-ls)
  290.   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
  291.   ;; FOUND is an unordered list of option specs for found options, while ETC
  292.   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
  293.   ;; options nor their values.
  294.   (let ((idx (map (lambda (spec)
  295.                     (cons (option-spec->name spec) spec))
  296.                   specs))
  297.         (sc-idx (map (lambda (spec)
  298.                        (cons (make-string 1 (option-spec->single-char spec))
  299.                              spec))
  300.                      (remove-if-not option-spec->single-char specs))))
  301.     (let loop ((argument-ls argument-ls) (found '()) (etc '()))
  302.       (let ((eat! (lambda (spec ls)
  303.                     (let ((val!loop (lambda (val n-ls n-found n-etc)
  304.                                       (set-option-spec-value!
  305.                                        spec
  306.                                        ;; handle multiple occurrances
  307.                                        (cond ((option-spec->value spec)
  308.                                               => (lambda (cur)
  309.                                                    ((if (list? cur) cons list)
  310.                                                     val cur)))
  311.                                              (else val)))
  312.                                       (loop n-ls n-found n-etc)))
  313.                           (ERR:no-arg (lambda ()
  314.                                         (error (string-append
  315.                                                 "option must be specified"
  316.                                                 " with argument:")
  317.                                                (option-spec->name spec)))))
  318.                       (cond
  319.                        ((eq? 'optional (option-spec->value-policy spec))
  320.                         (if (or (null? (cdr ls))
  321.                                 (looks-like-an-option (cadr ls)))
  322.                             (val!loop #t
  323.                                       (cdr ls)
  324.                                       (cons spec found)
  325.                                       etc)
  326.                             (val!loop (cadr ls)
  327.                                       (cddr ls)
  328.                                       (cons spec found)
  329.                                       etc)))
  330.                        ((eq? #t (option-spec->value-policy spec))
  331.                         (if (or (null? (cdr ls))
  332.                                 (looks-like-an-option (cadr ls)))
  333.                             (ERR:no-arg)
  334.                             (val!loop (cadr ls)
  335.                                       (cddr ls)
  336.                                       (cons spec found)
  337.                                       etc)))
  338.                        (else
  339.                         (val!loop #t
  340.                                   (cdr ls)
  341.                                   (cons spec found)
  342.                                   etc)))))))
  343.         (if (null? argument-ls)
  344.             (cons found (reverse etc))                          ;;; retval
  345.             (cond ((regexp-exec short-opt-rx (car argument-ls))
  346.                    => (lambda (match)
  347.                         (let* ((c (match-substring match 1))
  348.                                (spec (or (assoc-ref sc-idx c)
  349.                                          (error "no such option:" c))))
  350.                           (eat! spec argument-ls))))
  351.                   ((regexp-exec long-opt-no-value-rx (car argument-ls))
  352.                    => (lambda (match)
  353.                         (let* ((opt (match-substring match 1))
  354.                                (spec (or (assoc-ref idx opt)
  355.                                          (error "no such option:" opt))))
  356.                           (eat! spec argument-ls))))
  357.                   ((regexp-exec long-opt-with-value-rx (car argument-ls))
  358.                    => (lambda (match)
  359.                         (let* ((opt (match-substring match 1))
  360.                                (spec (or (assoc-ref idx opt)
  361.                                          (error "no such option:" opt))))
  362.                           (if (option-spec->value-policy spec)
  363.                               (eat! spec (append
  364.                                           (list 'ignored
  365.                                                 (match-substring match 2))
  366.                                           (cdr argument-ls)))
  367.                               (error "option does not support argument:"
  368.                                      opt)))))
  369.                   (else
  370.                    (loop (cdr argument-ls)
  371.                          found
  372.                          (cons (car argument-ls) etc)))))))))
  373.  
  374. (define (getopt-long program-arguments option-desc-list)
  375.   "Process options, handling both long and short options, similar to
  376. the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
  377. similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
  378. list of option descriptions.  Each option description must satisfy the
  379. following grammar:
  380.  
  381.     <option-spec>           :: (<name> . <attribute-ls>)
  382.     <attribute-ls>          :: (<attribute> . <attribute-ls>)
  383.                                | ()
  384.     <attribute>             :: <required-attribute>
  385.                                | <arg-required-attribute>
  386.                                | <single-char-attribute>
  387.                                | <predicate-attribute>
  388.                                | <value-attribute>
  389.     <required-attribute>    :: (required? <boolean>)
  390.     <single-char-attribute> :: (single-char <char>)
  391.     <value-attribute>       :: (value #t)
  392.                                (value #f)
  393.                                (value optional)
  394.     <predicate-attribute>   :: (predicate <1-ary-function>)
  395.  
  396.     The procedure returns an alist of option names and values.  Each
  397. option name is a symbol.  The option value will be '#t' if no value
  398. was specified.  There is a special item in the returned alist with a
  399. key of the empty list, (): the list of arguments that are not options
  400. or option values.
  401.     By default, options are not required, and option values are not
  402. required.  By default, single character equivalents are not supported;
  403. if you want to allow the user to use single character options, you need
  404. to add a `single-char' clause to the option description."
  405.   (let* ((specifications (map parse-option-spec option-desc-list))
  406.      (pair (split-arg-list (cdr program-arguments)))
  407.      (split-ls (expand-clumped-singles (car pair)))
  408.      (non-split-ls (cdr pair))
  409.          (found/etc (process-options specifications split-ls))
  410.          (found (car found/etc))
  411.          (rest-ls (append (cdr found/etc) non-split-ls)))
  412.     (for-each (lambda (spec)
  413.                 (let ((name (option-spec->name spec))
  414.                       (val (option-spec->value spec)))
  415.                   (and (option-spec->required? spec)
  416.                        (or (memq spec found)
  417.                            (error "option must be specified:" name)))
  418.                   (and (memq spec found)
  419.                        (eq? #t (option-spec->value-policy spec))
  420.                        (or val
  421.                            (error "option must be specified with argument:"
  422.                                   name)))
  423.                   (let ((pred (option-spec->predicate spec)))
  424.                     (and pred (pred name val)))))
  425.               specifications)
  426.     (cons (cons '() rest-ls)
  427.           (let ((multi-count (map (lambda (desc)
  428.                                     (cons (car desc) 0))
  429.                                   option-desc-list)))
  430.             (map (lambda (spec)
  431.                    (let ((name (string->symbol (option-spec->name spec))))
  432.                      (cons name
  433.                            ;; handle multiple occurrances
  434.                            (let ((maybe-ls (option-spec->value spec)))
  435.                              (if (list? maybe-ls)
  436.                                  (let* ((look (assq name multi-count))
  437.                                         (idx (cdr look))
  438.                                         (val (list-ref maybe-ls idx)))
  439.                                    (set-cdr! look (1+ idx)) ; ugh!
  440.                                    val)
  441.                                  maybe-ls)))))
  442.                  found)))))
  443.  
  444. (define (option-ref options key default)
  445.   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
  446. The value is either a string or `#t'."
  447.   (or (assq-ref options key) default))
  448.  
  449. ;;; getopt-long.scm ends here
  450.